home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Environments / Clean 1.2.4 / IO Examples / Small IO Examples / draw.icl < prev    next >
Encoding:
Text File  |  1997-06-20  |  17.8 KB  |  490 lines  |  [TEXT/3PRM]
  1. module draw
  2.  
  3. import StdEnv
  4. import deltaEventIO, deltaIOSystem, deltaPicture, deltaWindow, deltaDialog
  5.  
  6. ::    * IO        :==    IOState State
  7. ::    * State        =    {    tool        :: ToolIdType
  8.                     ,    sel_figs    :: [Drawable]
  9.                     ,    other_figs    :: [Drawable]
  10.                     ,    clip_board    :: [Drawable]
  11.                     }
  12. ::    ToolIdType    :==    Int
  13.  
  14. ::    Drawable    =    E.a: 
  15.                     {    state        :: a
  16.                     ,    move        :: a -> Point -> a
  17.                     ,    resize        :: a Point (Real,Real) -> a 
  18.                     ,    draw        :: a Picture -> Picture
  19.                     ,    bounds        :: a -> Rectangle
  20.                     ,    ungroup        :: a -> [Drawable]
  21.                     ,    contains    :: a Point -> Bool
  22.                     }
  23.  
  24.  
  25. instance + (a,b) | + a & + b
  26. where
  27.     (+) (x1,y1) (x2,y2) = (x1 + x2, y1 + y2)
  28.  
  29. instance - (a,b) | - a & - b
  30. where
  31.     (-) (x1,y1) (x2,y2) = (x1 - x2, y1 - y2)
  32.  
  33. (leq)  infix  4 :: !(a,b) !(a,b) -> Bool | < a & < b
  34. (leq) (x1,y1) (x2,y2) = x1 <= x2 && y1 <= y2
  35.  
  36. InRectangle :: Point Rectangle -> Bool
  37. InRectangle p (tl, br) = tl leq p && p leq br
  38.  
  39. ResizeRectangle :: Rectangle Point (Real,Real) -> Rectangle
  40. ResizeRectangle (tl,br) point (x_fact,y_fact)
  41. =    (    (toInt (toReal tl_x_diff * x_fact), toInt (toReal tl_y_diff * y_fact)) + point
  42.     ,    (toInt (toReal br_x_diff * x_fact), toInt (toReal br_y_diff * y_fact)) + point
  43.     )
  44. where
  45.     (tl_x_diff, tl_y_diff) = tl - point
  46.     (br_x_diff, br_y_diff) = br - point
  47.  
  48.  
  49. normalize ((x1,y1),(x2,y2)) = ((min x1 x2, min y1 y2), (max x1 x2, max y1 y2))
  50.  
  51. PI :== 3.1415926535898
  52.  
  53. LineMargin :== 3
  54.  
  55. MakeLine :: Line -> Drawable
  56. MakeLine line
  57. =    {    state        = line
  58.     ,    draw        = DrawLine
  59.     ,    move        = \line dist -> line + (dist, dist)     
  60.     ,    resize        = ResizeRectangle
  61.     ,    bounds        = \s -> normalize s
  62.     ,    ungroup        = \s -> []
  63.     ,    contains    = on_line  
  64.     }
  65. where
  66.     on_line line=:((x1,y1),(x2,y2)) (x3,y3)
  67.         = InRectangle (x3,y3) (tl_bound - (LineMargin,LineMargin), br_bound + (LineMargin,LineMargin)) && 
  68.                 abs (y_diff * (x3 - x1) - x_diff * (y3 - y1)) <= max (abs (x_diff * LineMargin)) (abs (y_diff * LineMargin))
  69.     where
  70.         (tl_bound, br_bound) = normalize line    
  71.         
  72.         x_diff = x2 - x1
  73.         y_diff = y2 - y1
  74.  
  75. OvalMargin = 3.0
  76.  
  77. MakeOval :: Oval -> Drawable
  78. MakeOval oval
  79. =    {    state        = normalize oval
  80.     ,    draw        = DrawOval
  81.     ,    move        = \oval dist -> oval + (dist, dist)     
  82.     ,    resize        = \oval point fact -> normalize (ResizeRectangle oval point fact)
  83.     ,    bounds        = \s -> s
  84.     ,    ungroup        = \s -> []
  85.     ,    contains    = on_oval  
  86.     }
  87. where
  88.     on_oval (tl=:(tl_x,tl_y),br=:(br_x,br_y)) point
  89.         = abs (sqrt sqr_dist_to_centre - toReal x_radius) <= norm_margin
  90.     where
  91.         sqr_dist_to_centre = sqr_x + sqr_y * mul_fact
  92.         
  93.         sqr_y    = toReal (y * y)
  94.         sqr_x    = toReal (x * x)
  95.         
  96.         sqr_x_radius = toReal (x_radius * x_radius)
  97.         sqr_y_radius = toReal (y_radius * y_radius)
  98.         
  99.         mul_fact = sqr_x_radius / sqr_y_radius
  100.         
  101.         norm_margin = OvalMargin * sqrt (1.0 + mul_fact)
  102.         
  103.         (x,y) = point - (tl_x + x_radius,tl_y + y_radius)
  104.         
  105.         x_radius = max ((br_x - tl_x) / 2) 1
  106.         y_radius = max ((br_y - tl_y) / 2) 1
  107.  
  108.  
  109. Move :: [Drawable]  Point -> [Drawable]
  110. Move drawables dist = map (\ drawable=:{move,state} -> { drawable & state = move state dist}) drawables
  111.  
  112. Resize :: [Drawable]  Point  (Real,Real) -> [Drawable]
  113. Resize drawables point fact = map (\ drawable=:{resize,state} -> { drawable & state = resize state point fact}) drawables
  114.  
  115. Draw :: [Drawable] Picture -> Picture
  116. Draw drawables pict = foldl (\p {draw,state} -> draw state p) pict drawables
  117.  
  118. Bounds :: [Drawable] -> Rectangle
  119. Bounds [] =    ((0, 0), (0, 0))
  120. Bounds drawables = foldl combine_bounds bound rest_bounds
  121. where
  122.     combine_bounds ((r1tlx,r1tly),(r1brx,r1bry)) ((r2tlx,r2tly),(r2brx,r2bry))
  123.         = ((min r1tlx r2tlx,min r1tly r2tly),(max r1brx r2brx,max r1bry r2bry))
  124.     
  125.     [bound:rest_bounds] = map (\{bounds,state} -> bounds state) drawables
  126.  
  127. Contains :: [Drawable] Point -> Bool
  128. Contains drawables point = foldr ((||) o \{contains,state} -> contains state point) False drawables
  129.  
  130. Ungroup :: [Drawable] -> [Drawable]
  131. Ungroup []
  132. =    []
  133. Ungroup [drawable=:{ungroup,state} : drawables]
  134. =    case ungroup state of
  135.         []        -> [drawable : Ungroup drawables]
  136.         list    -> list ++ Ungroup drawables
  137.  
  138. MakeRectangle :: Rectangle -> [Line]
  139. MakeRectangle ((x1,y1),(x2,y2)) = [((x1,y1),(x1,y2)), ((x1,y2),(x2,y2)),((x2,y2),(x2,y1)),((x2,y1),(x1,y1))]
  140.  
  141. MakeGroup :: [Drawable] -> Drawable
  142. MakeGroup drawables
  143. =    {    state     = drawables
  144.     ,    move     = Move
  145.     ,    resize     = Resize 
  146.     ,    draw     = Draw
  147.     ,    bounds     = Bounds
  148.     ,    ungroup     = \s -> s
  149.     ,    contains = Contains
  150.     }
  151.  
  152. FileId        :== 1;
  153.     QuitId            :== 11;
  154. EditId    :== 2;
  155.     CutId            :== 21;
  156.     CopyId            :== 22;
  157.     PasteId            :== 23;
  158. ArrangeId    :== 3;
  159.     GroupId            :== 31;
  160.     UngroupId        :== 32;
  161. ToolId        :== 4;
  162.     SelectToolId    :== 41;
  163.     RectangleToolId    :== 42;
  164.     LineToolId        :== 43;
  165.     OvalToolId        :== 44;
  166.  
  167. InitState    = { tool = SelectToolId, other_figs = [fig], sel_figs = [], clip_board = [] }
  168. where
  169.     rect    = MakeGroup (map  MakeLine (MakeRectangle  ((10,10),(50,50))))
  170.     fig        = MakeGroup [rect, line, MakeGroup (map  MakeLine (MakeRectangle  ((50,70), (110,190))))]
  171.     line    = MakeLine ((20,20), (90,80))
  172.  
  173.  
  174. Start :: * World -> * World
  175. Start world
  176. #    (events, world)    = OpenEvents world
  177.     (_, events)        = StartIO [menu, window] InitState [] events
  178.     world            = CloseEvents events world
  179. =    world
  180. where
  181.     menu            = MenuSystem [file, edit, arrange, tool]
  182.     
  183.     file            = PullDownMenu FileId "File" Able
  184.                         [    MenuItem  QuitId "Quit" (Key 'Q') Able Quit    ]
  185.                 
  186.     edit            = PullDownMenu EditId "Edit" Able
  187.                         [    MenuItem  CutId   "Cut"   (Key 'X') Able Cut
  188.                         ,    MenuItem  CopyId  "Copy"  (Key 'C') Able Copy
  189.                         ,    MenuItem  PasteId "Paste" (Key 'V') Able Paste
  190.                         ]
  191.                 
  192.     arrange            = PullDownMenu ArrangeId "Arrange" Able
  193.                         [    MenuItem  GroupId   "Group"   (Key 'G') Able DoGroup
  194.                         ,    MenuItem  UngroupId "Ungroup" (Key 'U') Able DoUngroup
  195.                         ]
  196.  
  197.     tool            = PullDownMenu ToolId "Draw" Able
  198.                         [    MenuRadioItems SelectToolId 
  199.                             [    MenuRadioItem SelectToolId    "Select"    NoKey Able (SetTool SelectToolId StandardCursor)
  200.                             ,    MenuRadioItem RectangleToolId "Rectangle" NoKey Able (SetTool RectangleToolId CrossCursor)
  201.                             ,    MenuRadioItem LineToolId      "Line"      NoKey Able (SetTool LineToolId CrossCursor)
  202.                             ,    MenuRadioItem OvalToolId      "Oval"      NoKey Able (SetTool OvalToolId CrossCursor)
  203.                             ]
  204.                         ]
  205.     
  206.     window            = WindowSystem [picture]
  207.     picture            = ScrollWindow 1 (0,0) "Picture"  
  208.                         (ScrollBar (Thumb 0) (Scroll 10)) (ScrollBar (Thumb 0) (Scroll 10))
  209.                         ((0,0), (1000,1000)) (50,50) (500,300) Update
  210.                         [Mouse Able JerryWaits, GoAway Quit]
  211.  
  212.  
  213. SetTool :: Int CursorShape State IO -> (State, IO)
  214. SetTool tool_id cursor state=:{tool} io
  215. |    tool_id == tool        = (state, io)
  216. |    otherwise            = ({state & tool = tool_id}, ChangeActiveWindowCursor cursor io)
  217.  
  218. SelMarkerWidth :== 3
  219.  
  220. MakeSelectionSquare :: Point -> Rectangle
  221. MakeSelectionSquare p = (p - (SelMarkerWidth-1,SelMarkerWidth-1), p + (SelMarkerWidth,SelMarkerWidth))
  222.  
  223. Select :: [Drawable] Picture -> Picture
  224. Select drawables pict
  225. =    foldr (DrawSelectionMarkers o (\{bounds,state} -> bounds state)) pict drawables
  226. where
  227.     DrawSelectionMarkers :: Rectangle Picture -> Picture
  228.     DrawSelectionMarkers ((tlx,tly), (brx,bry)) pict
  229.     |    tlx == brx            = DrawSelectionMarker (tlx,tly) (DrawSelectionMarker (tlx,bry) pict)
  230.     |    tly == bry            = DrawSelectionMarker (tlx,tly) (DrawSelectionMarker (brx,tly) pict)
  231.     |    otherwise            = DrawSelectionMarker (tlx,tly) (DrawSelectionMarker (tlx,bry)
  232.                              (DrawSelectionMarker (brx,bry) (DrawSelectionMarker (brx,tly) pict)))
  233.     
  234.     DrawSelectionMarker :: Point Picture -> Picture
  235.     DrawSelectionMarker p pict = FillRectangle (MakeSelectionSquare p) pict
  236.  
  237. ClearSelectedFigures :: [Drawable] [Drawable] Picture -> Picture
  238. ClearSelectedFigures [] not_selected pict
  239. =    pict
  240. ClearSelectedFigures figures not_selected pict
  241. =    UpdateWindow [update_rect] [] not_selected (EraseRectangle update_rect pict)
  242. where
  243.     update_rect    = Bounds figures + ((1-SelMarkerWidth,1-SelMarkerWidth),(SelMarkerWidth,SelMarkerWidth))
  244.  
  245.  
  246. Quit state io = (state, QuitIO io)
  247.  
  248. Copy state=:{sel_figs} io = ({ state & clip_board = Move sel_figs (20,20)}, io)
  249.  
  250. Cut state=:{sel_figs,other_figs} io
  251. =    ({ state & clip_board = Move sel_figs (20,20), sel_figs = []}, DrawInActiveWindow [ClearSelectedFigures sel_figs other_figs] io)
  252.  
  253. Paste state=:{clip_board, sel_figs, other_figs} io
  254. =    ({ state & sel_figs = clip_board, other_figs = not_selected }, draw_window)
  255. where
  256.     not_selected    = sel_figs ++ other_figs
  257.     draw_window        = DrawInActiveWindow [    ClearSelectedFigures sel_figs not_selected
  258.                                          ,    Draw clip_board, SetPenMode XorMode, Select clip_board, SetPenMode CopyMode
  259.                                          ]    io
  260.  
  261. DoGroup state=:{sel_figs,other_figs} io
  262. =    ({ state & sel_figs = group }, DrawInActiveWindow draw_group io)
  263. where
  264.     draw_group    = [SetPenMode XorMode, Select sel_figs, Select group, SetPenMode CopyMode]
  265.     group        = [MakeGroup sel_figs]
  266.  
  267. DoUngroup state=:{sel_figs,other_figs} io
  268. =    ({ state & sel_figs = group_elems }, DrawInActiveWindow draw_group_elems io)
  269. where
  270.     draw_group_elems = [SetPenMode XorMode, Select sel_figs, Select group_elems, SetPenMode CopyMode]
  271.     group_elems = Ungroup sel_figs
  272.  
  273. Update :: UpdateArea State -> (State, [DrawFunction])
  274. Update area state=:{sel_figs,other_figs}
  275. =    (state, [UpdateWindow area sel_figs other_figs])
  276.  
  277. UpdateWindow :: UpdateArea [Drawable] [Drawable] Picture -> Picture
  278. UpdateWindow area selected not_selected pict
  279. =    SetPenMode CopyMode (Select redraw_sel_figs (SetPenMode XorMode (Draw (redraw_other_figs ++ redraw_sel_figs) pict)))
  280. where
  281.     redraw_sel_figs        = DetermineRedraws area selected []
  282.     redraw_other_figs    = DetermineRedraws area not_selected []
  283.     
  284.     DetermineRedraws [] drawables selected = selected
  285.     DetermineRedraws [rect:rects] drawables selected
  286.     =    DetermineRedraws rects remaining (tobedrawn ++ selected)
  287.     where
  288.         (tobedrawn, remaining) = Split (intersect rect) drawables
  289.         
  290.         intersect :: Rectangle (Drawable) -> Bool
  291.         intersect (tl1,br1) {bounds,state}
  292.         =    tl1 leq br2 && tl2 leq br1
  293.         where
  294.             (tl2,br2) = bounds state
  295.  
  296. RetrieveSelectedFigures :: Point [Drawable] -> ([Drawable], [Drawable])
  297. RetrieveSelectedFigures point drawables = Split ( \{contains,state} -> contains state point) drawables
  298.  
  299. RetrieveSurroundedFigures :: Rectangle [Drawable] -> ([Drawable], [Drawable])
  300. RetrieveSurroundedFigures rect drawables
  301. =    Split (is_surrounding (normalize rect) o \{bounds,state} -> bounds state) drawables
  302. where
  303.     is_surrounding (r1tl,r1br) (r2tl,r2br) = r1tl leq r2tl && r2br leq r1br
  304.  
  305. ResizeAreaIsSelected  :: Point [Drawable] -> (Bool, Rectangle)
  306. ResizeAreaIsSelected point [{bounds,state}]
  307. |    InRectangle point (MakeSelectionSquare (tlx,tly))    = (True, ((brx,bry), (tlx,tly)))
  308. |    InRectangle point (MakeSelectionSquare (brx,bry))    = (True, ((tlx,tly), (brx,bry)))
  309. |    InRectangle point (MakeSelectionSquare (tlx,bry))    = (True, ((brx,tly), (tlx,bry)))
  310. |    InRectangle point (MakeSelectionSquare (brx,tly))    = (True, ((tlx,bry), (brx,tly)))
  311. |    otherwise                                            = (False, Omega)
  312. where
  313.     ((tlx,tly),(brx,bry))                                = bounds state
  314. ResizeAreaIsSelected point _                            = (False, Omega)
  315.  
  316. Split :: (x -> .Bool) .[x] -> (.[x],.[x])
  317. Split p []        = ([], [])
  318. Split p [x:xs]
  319. |    p x            = ([x:as], bs)
  320. |    otherwise    = (as, [x:bs])
  321. where
  322.     (as, bs)    = Split p xs
  323.  
  324. Omega :: .x
  325. Omega = abort "tried to access an undefined expression"
  326.  
  327. DrawBoundingBox :: Rectangle Picture -> Picture
  328. DrawBoundingBox rect pict = SetPenPattern BlackPattern (foldr DrawLine (SetPenPattern GreyPattern pict) (MakeRectangle rect))
  329.  
  330. JerryWaits :: MouseState State IO -> (State, IO)
  331. JerryWaits (pos, ButtonDown, (shift,_,_,_)) state=:{tool, other_figs, sel_figs} io
  332. |    tool <> SelectToolId
  333.     = (    { state & sel_figs = [], other_figs = other_figs ++ sel_figs }
  334.       ,    ChangeActiveMouseFunction (JerryDraws tool (pos, pos))
  335.                     (DrawInActiveWindow [SetPenMode XorMode, Select sel_figs] io)
  336.       )
  337. |    not shift && have_to_resize
  338.     = (    state
  339.       ,    ChangeActiveMouseFunction (JerryResizes resize_rect pos)
  340.                     (DrawInActiveWindow [    SetPenMode XorMode, Select sel_figs
  341.                                         ,    SetPenMode OrMode, DrawBoundingBox resize_rect, SetPenMode XorMode
  342.                                         ]    io)
  343.       )
  344. |    Contains sel_figs pos
  345.     = if (shift)
  346.         (    { state & sel_figs = not_selected, other_figs = other_figs ++ selected}
  347.         ,    DrawInActiveWindow [SetPenMode XorMode, Select selected, SetPenMode CopyMode] io
  348.         )
  349.         (    state
  350.         ,    ChangeActiveMouseFunction (JerryWaitsForDragging pos sel_figs) io
  351.         )
  352.     with
  353.         (selected, not_selected) = RetrieveSelectedFigures pos sel_figs
  354. |    isEmpty selected
  355.     = if (shift)
  356.         (    state
  357.         ,    ChangeActiveMouseFunction (JerrySelects (pos, pos)) io
  358.         )
  359.         (    { state & sel_figs = [], other_figs = other_figs ++ sel_figs}
  360.         ,    ChangeActiveMouseFunction (JerrySelects (pos, pos))
  361.                     (DrawInActiveWindow [SetPenMode XorMode, Select sel_figs, SetPenMode CopyMode] io)
  362.         )
  363. |    otherwise
  364.     = if (shift)
  365.         (    { state & sel_figs = selected ++ sel_figs, other_figs = not_selected }
  366.         ,    ChangeActiveMouseFunction (JerryWaitsForDragging pos (selected ++ sel_figs))
  367.                     (DrawInActiveWindow [SetPenMode XorMode, Select selected, SetPenMode CopyMode] io)
  368.         )
  369.         (    { state & sel_figs = selected, other_figs = not_selected ++ sel_figs }
  370.         ,    ChangeActiveMouseFunction (JerryWaitsForDragging pos selected)
  371.                     (DrawInActiveWindow [SetPenMode XorMode, Select (selected ++ sel_figs), SetPenMode CopyMode] io)
  372.         )
  373. where
  374.     (selected, not_selected) = RetrieveSelectedFigures pos other_figs
  375.     (have_to_resize, resize_rect) = ResizeAreaIsSelected pos sel_figs
  376.  
  377. JerryWaits mouse state io = (state, io)
  378.  
  379. JerrySelects :: Rectangle MouseState State IO -> (State, IO)
  380. JerrySelects  rect=:(top_left,bot_right) (pos, ButtonUp, mods) state=:{sel_figs,other_figs} io
  381. =    (    { state & sel_figs = selected ++ sel_figs, other_figs = not_selected }
  382.     ,    ChangeActiveMouseFunction JerryWaits (DrawInActiveWindow draw_figure io)
  383.     )
  384. where
  385.     (selected, not_selected) = RetrieveSurroundedFigures (top_left, pos) other_figs
  386.     draw_figure    = [    SetPenMode XorMode, DrawRectangle rect, Select selected, SetPenMode CopyMode]
  387.  
  388. JerrySelects rect=:(top_left, bot_right) (pos, buttondown, mods) state io
  389. |    bot_right == pos
  390.         = (state, io)
  391. |    otherwise
  392.         = (state, ChangeActiveMouseFunction (JerrySelects new_rect) (DrawInActiveWindow draw_tmp_rectangle io))
  393. where
  394.     new_rect = (top_left, pos)
  395.     draw_tmp_rectangle    = [SetPenMode XorMode, DrawRectangle rect, DrawRectangle new_rect]
  396.  
  397.  
  398. JerryWaitsForDragging :: Point [Drawable] MouseState State IO -> (State, IO)
  399. JerryWaitsForDragging prev_pos selected (pos, ButtonUp, _) state io
  400.     = (state, ChangeActiveMouseFunction JerryWaits io)
  401. JerryWaitsForDragging prev_pos selected (pos, _, _)  state io
  402. |    prev_pos == pos
  403.     = (state, io)
  404. |    otherwise
  405.     = (state, ChangeActiveMouseFunction (JerryDrags pos moved_figures)
  406.                 (DrawInActiveWindow  [SetPenMode XorMode, Draw moved_figures, SetPenMode CopyMode] io))
  407. where
  408.     moved_figures = Move selected (pos - prev_pos)
  409.  
  410.  
  411. JerryDrags :: Point [Drawable] MouseState State IO -> (State, IO)
  412. JerryDrags prev_pos selected (pos, ButtonUp, mods)  state=:{sel_figs, other_figs} io
  413.     = ( { state & sel_figs = new_figs }, ChangeActiveMouseFunction JerryWaits (DrawInActiveWindow draw_figures io))
  414. where
  415.     new_figs        = Move selected    (pos - prev_pos)
  416.     draw_figures    = [    SetPenMode XorMode,  Draw selected, SetPenMode CopyMode
  417.                       ,    ClearSelectedFigures sel_figs other_figs
  418.                       ,    Draw new_figs, SetPenMode XorMode, Select new_figs, SetPenMode CopyMode
  419.                       ]
  420.  
  421. JerryDrags prev_pos selected (pos, _, mods) state io
  422. |    prev_pos == pos
  423.     = (state, io)
  424. |    otherwise
  425.     = (state, ChangeActiveMouseFunction (JerryDrags pos moved_figures)
  426.                         (DrawInActiveWindow [SetPenMode XorMode, Draw (selected ++ moved_figures), SetPenMode CopyMode] io))
  427. where
  428.     moved_figures = Move selected (pos - prev_pos)
  429.  
  430.  
  431. DrawFigure :: ToolIdType Rectangle Picture -> Picture
  432. DrawFigure tool rect pict
  433. |    tool == RectangleToolId        = DrawRectangle rect pict
  434. |    tool == LineToolId            = DrawLine rect pict
  435. |    otherwise                    = DrawOval rect pict
  436.  
  437. MakeFigure :: ToolIdType Rectangle -> Drawable
  438. MakeFigure tool rect
  439. |    tool == RectangleToolId        = MakeGroup (map  MakeLine (MakeRectangle rect))
  440. |    tool == LineToolId            = MakeLine rect
  441. |    otherwise                    = MakeOval rect
  442.  
  443.  
  444. JerryDraws :: ToolIdType Rectangle MouseState State IO -> (State, IO)
  445. JerryDraws tool  rect=:(top_left,bot_right) (pos, ButtonUp, _) state io
  446. =    ({ state & sel_figs = [new_fig] }, ChangeActiveMouseFunction JerryWaits (DrawInActiveWindow draw_figure io))
  447. where
  448.     new_fig        = MakeFigure tool (top_left, pos)
  449.     draw_figure    = [    DrawFigure tool rect, SetPenMode CopyMode, Draw [new_fig]
  450.                   ,    SetPenMode XorMode, Select [new_fig], SetPenMode CopyMode
  451.                   ]
  452. JerryDraws tool rect=:(top_left, bot_right) (pos, _ , _) state io
  453. |    bot_right == pos
  454.     = (state, io)
  455. |    otherwise
  456.     = (state, ChangeActiveMouseFunction (JerryDraws tool new_rect) (DrawInActiveWindow draw_figure io))
  457. where
  458.     new_rect = (top_left, pos)
  459.     draw_figure    = [DrawFigure tool rect, DrawFigure tool new_rect]
  460.  
  461. DetermineMultiplicationFactor :: Point Point Point -> (!Real, !Real)
  462. DetermineMultiplicationFactor (tlx,tly) (old_brx,old_bry) (new_brx,new_bry)
  463. =    (toReal (new_brx - tlx) / toReal (old_brx - tlx), toReal (new_bry - tly) / toReal (old_bry - tly))
  464.  
  465. DrawResizeRectangle :: Point Point Point Picture -> Picture
  466. DrawResizeRectangle (tl_x,tl_y) rs_br=:(rs_br_x,rs_br_y) bo_br=:(bo_br_x,bo_br_y) pict
  467. =    DrawLine ((tl_x, rs_br_y), rs_br) (DrawLine ((rs_br_x, tl_y), rs_br) pict)
  468.  
  469. JerryResizes :: Rectangle Point MouseState State IO -> (State, IO)
  470. JerryResizes resize_rect=:(top_left,bot_right) orig_bot_right (pos, ButtonUp, _ ) state=:{sel_figs, other_figs} io
  471. =    ({ state & sel_figs = new_figs }, ChangeActiveMouseFunction JerryWaits (DrawInActiveWindow draw_figure io))
  472. where
  473.     new_figs    = Resize sel_figs top_left (DetermineMultiplicationFactor top_left orig_bot_right pos)
  474.     draw_figure    = [    DrawResizeRectangle top_left bot_right orig_bot_right, SetPenMode CopyMode
  475.                   ,    ClearSelectedFigures sel_figs other_figs
  476.                   ,    Draw new_figs
  477.                    ,    SetPenMode XorMode, Select new_figs, SetPenMode CopyMode
  478.                    ]
  479.  
  480. JerryResizes resize_rect=:(top_left,bot_right) orig_bot_right (pos, _, _) state io
  481. |    bot_right == pos
  482.     = (state, io)
  483. |    otherwise
  484.     = (state, ChangeActiveMouseFunction (JerryResizes new_resize_rect orig_bot_right) (DrawInActiveWindow draw_figure io))
  485. where
  486.     new_resize_rect = (top_left, pos)
  487.     draw_figure    = if (orig_bot_right == pos)
  488.                         [DrawResizeRectangle top_left pos orig_bot_right]        
  489.                         [DrawResizeRectangle top_left bot_right orig_bot_right, DrawResizeRectangle top_left pos orig_bot_right]
  490.